home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / debug / profile.scm < prev    next >
Text File  |  1995-10-13  |  3KB  |  108 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; This was a fun hack, but I didn't get much useful information out of
  4. ; it -- a profiler that only samples at points allowed by the VM's
  5. ; interrupt mechanism doesn't tell you what you want to know.  The
  6. ; only information available at that point is the continuation; what
  7. ; we really want to know is where the PC has been.  In particular, the
  8. ; only procedures that show up in the table at all are those that call
  9. ; other procedures.    JAR 12/92
  10.  
  11. '
  12. (define-structure profiler (export profile one-second)
  13.   (open scheme-level-2 handle exception ;interrupts
  14.     architecture continuation signals condition template
  15.     table structure-refs debug-data sort
  16.     primitives) ;schedule-interrupt
  17.   (files (misc profile)))
  18.  
  19. (define (profile thunk frequency)
  20.   (let ((table (make-table template-uid))
  21.     (dt (round (/ one-second frequency))))
  22.     (primitive-catch
  23.       (lambda (k0)
  24.     (let ((foo (continuation-template k0)))
  25.       (with-handler
  26.           (lambda (c punt)
  27.         (if (and (interrupt? c)
  28.              (eq? (interrupt-type c) interrupt/alarm))
  29.             (primitive-catch
  30.               (lambda (k)
  31.             (record-profile-information! k foo table)
  32.             (schedule-interrupt dt)))
  33.             (punt)))
  34.         (lambda ()
  35.           (dynamic-wind (lambda () (schedule-interrupt dt))
  36.                 thunk
  37.                 (lambda () (schedule-interrupt 0))))))))
  38.     table))
  39.  
  40. (define (record-profile-information! k k0-template table)
  41.   (let ((k1 (continuation-cont (continuation-cont k))))
  42.     (let ((z (get-counts table k1)))
  43.       (set-car! z (+ (car z) 1))
  44.       (set-cdr! z (+ (cdr z) 1)))
  45.     (do ((k (continuation-parent k1) (continuation-parent k)))
  46.     ((or (not (continuation? k))
  47.          (eq? (continuation-template k) k0-template)))
  48.       (let ((z (get-counts table k)))
  49.     (set-cdr! z (+ (cdr z) 1))))))
  50.  
  51. (define (get-counts table k)
  52.   (let ((info (template-info (continuation-template k))))
  53.     (or (table-ref table info)
  54.     (let ((z (cons 0 0)))
  55.       (table-set! table info z)
  56.       z))))
  57.  
  58. (define (template-uid info)
  59.   (cond ((integer? info)
  60.      info)
  61.     ((debug-data? info)
  62.      (debug-data-uid info))
  63.     (else 0)))  ;??
  64.  
  65. (define interrupt-type cadr)
  66. (define interrupt/alarm (enum interrupt alarm))
  67.  
  68. (define (dump t)
  69.   (let ((l '()))
  70.     (table-walk (lambda (key count)
  71.           (let ((dd (if (integer? key)
  72.                 (table-ref debug-data-table key)
  73.                 key)))
  74.             (set! l (cons (cons count
  75.                     (if (debug-data? dd)
  76.                         (debug-data-names dd)
  77.                         `(? ,key)))
  78.                   l))))
  79.         t)
  80.     (do ((l (sort-list l more-interesting?)
  81.         (cdr l))
  82.      (i 0 (+ i 1)))
  83.     ((or (null? l) (> i *prefix*)))
  84.       (let* ((counts+names (car l))
  85.          (leaf-count (caar counts+names))
  86.          (total-count (cdar counts+names))
  87.          (names (cdr counts+names)))
  88.     (display (pad-left total-count 6)) (display #\space)
  89.     (display (pad-left leaf-count 6)) (display #\space)
  90.     (write names)
  91.     (newline)))))
  92.  
  93. (define (more-interesting? x y)
  94.   (let ((c1 (cdar x))
  95.     (c2 (cdar y)))
  96.     (or (> c1 c2)
  97.     (and (= c1 c2)
  98.          (> (caar x) (caar y))))))
  99.  
  100.  
  101. (define *prefix* 60)
  102. (define (pad-left s n)
  103.   (let ((s (cond ((number? s) (number->string s))
  104.          ((symbol? s) (symbol->string s))
  105.          (else s))))
  106.     (string-append (make-string (- n (string-length s)) #\space)
  107.            s)))
  108.